home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / excl-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-09-10  |  5.0 KB  |  156 lines
  1. ;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;; 
  27. ;;; This is the EXCL (Franz) lisp version of the file portable-low.
  28. ;;; 
  29. ;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
  30. ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
  31. ;;; a later release so this will need to be changed.
  32. ;;; 
  33.  
  34. (in-package 'pcl)
  35.  
  36. (defmacro without-interrupts (&body body)
  37.   `(let ((outer-interrupts excl::*without-interrupts*)
  38.      (excl::*without-interrupts* 0))
  39.      (macrolet ((interrupts-on  ()
  40.           '(unless outer-interrupts
  41.              (setq excl::*without-interrupts* nil)))
  42.         (interrupts-off ()
  43.           '(setq excl::*without-interrupts* 0)))
  44.        ,.body)))
  45.  
  46. (defmacro without-interrupts-simple (&body body)
  47.   `(let ((excl::*without-interrupts* 0))
  48.      ,.body))
  49.  
  50. (eval-when (compile load eval)
  51.   (unless (fboundp 'excl::sy_hash)
  52.     (setf (symbol-function 'excl::sy_hash)
  53.       (symbol-function 'excl::_sy_hash-value)))
  54.   )
  55.  
  56. (defmacro memq (item list)
  57.   (let ((list-var (gensym))
  58.     (item-var (gensym)))
  59.     `(prog ((,list-var ,list)
  60.         (,item-var ,item))
  61.     start
  62.        (cond ((null ,list-var)
  63.           (return nil))
  64.          ((eq (car ,list-var) ,item-var)
  65.           (return ,list-var))
  66.          (t
  67.           (pop ,list-var)
  68.           (go start))))))
  69.  
  70. (defmacro structurep (x)
  71.   `(excl::structurep ,x))
  72.  
  73. (defmacro structure-type (x)
  74.   `(svref ,x 0))
  75.  
  76. (defun std-instance-p (x)
  77.   (and (excl::structurep x)
  78.        (locally
  79.      (declare #.*optimize-speed*)
  80.      (eq (svref x 0) 'std-instance))))
  81.  
  82. (excl::defcmacro std-instance-p (x)
  83.   (once-only (x)
  84.     `(and (excl::structurep ,x)
  85.       (locally
  86.         (declare #.*optimize-speed*)
  87.         (eq (svref ,x 0) 'std-instance)))))
  88.  
  89. (defmacro %std-instance-wrapper (x)
  90.   `(svref ,x 1))
  91.  
  92. (defmacro %std-instance-slots (x)
  93.   `(svref ,x 2))
  94.  
  95. (defun printing-random-thing-internal (thing stream)
  96.   (format stream "~O" (excl::pointer-to-fixnum thing)))
  97.  
  98. #-vax
  99. (defun set-function-name-1 (fn new-name ignore)
  100.   (declare (ignore ignore))
  101.   (cond ((excl::function-object-p fn)
  102.      (setf (excl::fn_symdef fn) new-name))
  103.     (t nil))
  104.   fn)
  105.  
  106. (defun function-arglist (f)
  107.   (excl::arglist f))
  108.  
  109. (defun symbol-append (sym1 sym2 &optional (package *package*))
  110.    ;; This is a version of symbol-append from macros.cl
  111.    ;; It insures that all created symbols are of one case and that
  112.    ;; case is the current prefered case.
  113.    ;; This special version of symbol-append is not necessary if all you
  114.    ;; want to do is compile and run pcl in a case-insensitive-upper 
  115.    ;; version of cl.  
  116.    ;;
  117.    (let ((string (string-append sym1 sym2)))
  118.       (case excl::*current-case-mode*
  119.      ((:case-insensitive-lower :case-sensitive-lower)
  120.       (setq string (string-downcase string)))
  121.      ((:case-insensitive-upper :case-sensitive-upper)
  122.       (setq string (string-upcase string))))
  123.       (intern string package)))
  124.  
  125. ;;; Define inspector hooks for PCL object instances.
  126.  
  127. ;;; Due to metacircularity certain slots of metaclasses do not have normal
  128. ;;; accessors, and for now we just make them uninspectable.  They could be
  129. ;;; special cased some day.
  130.  
  131. (defun (:property pcl::std-instance :inspector-function) (object)
  132.   (do* ((class (class-of object))
  133.     (components (class-precedence-list class))
  134.     (desc (list (inspect::make-field-def "class" #'class-of :lisp)))
  135.     (slots (slots-to-inspect class object) (cdr slots)))
  136.        ((null slots) (nreverse desc))
  137.     (let ((name (slot-definition-name (car slots)))
  138.       res)
  139.       (push (inspect::make-field-def
  140.          (string name)
  141.          (or (block foo
  142.            (dolist (comp components)
  143.              (dolist (slot (class-direct-slots comp))
  144.                (and (eq (slot-definition-name slot) name)
  145.                 (setq res (first (slot-definition-readers slot)))
  146.                 (return-from foo res)))))
  147.          #'(lambda (x) 
  148.              (declare (ignore x))
  149.              :|Uninspectable Metaclass Slot|))
  150.          :lisp)
  151.         desc))))
  152.  
  153. (defun (:property pcl::std-instance :inspector-type-function) (x)
  154.   (class-name (class-of x)))
  155.  
  156.